NeXT Education Software Sampler 1992 Fall

home *** CD-ROM | disk | FTP | other *** search

/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Mathematics / Notebooks / SigProc2.0 / Packages / SignalProcessing / Support / SupCode.m < prev next >

Wrap

Text File | 1992-08-18 | 41.2 KB | 1,365 lines

(* :Title: Supporting Routines *) (* :Authors: Brian Evans, James McClellan *) (* :Summary: To provide routines that Mathematica should have. Many are borrowed from Lisp. *) (* :Context: SignalProcessing`Support`SupCode` *) (* :PackageVersion: 2.7 *) (* :Copyright: Copyright 1989-1991 by Brian L. Evans Georgia Tech Research Corporation Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation, and that the name of the Georgia Tech Research Corporation, Georgia Tech, or Georgia Institute of Technology not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Georgia Tech makes no representations about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. *) (* :History: *) (* :Keywords: list processing, sequences, number theory, set theory *) (* :Source: *) (* :Warning: *) (* :Mathematica Version: 1.2 or 2.0 *) (* :Limitation: *) (* :Functions: AllSubsets Arrow2D AssociateItem Assuming CirclePS Combine ComplexQ ComplexTo2DCoord ComplexTo2DCoordList ConstantQ ConstantTerm Dialogue Element EmptyQ GenerateCode GeneratePattern GenerateSymbol GetAllExponents GetAllFactors GetAllShiftFactors GetArgs GetRoot GetRootList GetShiftFactor GetStateField GetVariables GetValue HasAttributes ImaginaryQ InRange InfinityQ InformUserQ ListQ MixedPolynomialQ MyApart MyCollectAll MyFreeQ MyMessage PatternQ PointwisePlot PrintIt ProtectIt RationalQ RationalFunctionQ RationalPolynomialQ RealQ RealValuedQ RemoveOptions ReplaceWith RuleAppliesQ SameFormQ Second SetExclusion SetStateField StripPackage SubsetQ TableLookup Third ToCollection ToList UnprotectIt VariableQ ZeroQ ZPolynomial *) If [ ! TrueQ[ $VersionNumber >= 2.0 ], $Packages := $ContextPath; $Packages::usage = "$Packages gives a list of the contexts corresponding to all packages \ which have been loaded in your current Mathematica session."; Protect[$Packages] ] $loaded = MemberQ[ $Packages, "SignalProcessing`Support`SupCode`" ] If [ TrueQ[ $VersionNumber >= 2.0 ], Unprotect[ ListQ ]; Clear[ ListQ ]; $NewMessage[ System`Set, "wrsym" ]; $NewMessage[ System`SetDelayed, "write" ]; Off[ Set::wrsym ]; Off[ SetDelayed::write ]; $NewMessage[ System`General, "spell" ]; $NewMessage[ System`General, "spell1" ]; Off[ General::spell ]; Off[ General::spell1 ] ] (* B E G I N P A C K A G E *) BeginPackage[ "SignalProcessing`Support`SupCode`" ] (* U S A G E I N F O R M A T I O N *) AllSubsets::usage = "AllSubsets[set] returns a list of all subsets of set, \ including the null set {}. \ The original set must be a lis." Arrow2D::usage = "Arrow2D[tail, plotwidth, plotheight] returns a graphics object \ that is an arrow starting at tail, pointing upwards, of \ length plotheight. \ The length of the tail and the direction of the arrow are controlled \ by an optional fourth parameter." AssociateItem::usage = "AssociateItem[item, lookuplist, newlist] finds the location of \ item in the lookuplist and returns the element of newlist in \ that position. \ If item is not is lookup list, Null is returned. \ If item is a list, then a list of associations is returned." Assuming::usage = "Assuming[condition] keeps track of assumptions made during \ a calculation. \ Assuming[All] gives all of the current assumptions. \ Assuming[condition, True] prints the condition if it is not True. \ Assuming[] removes all current assumptions." CirclePS::usage = "CirclePS[r] and CirclePS[r, p] will return a graphics object, \ a circle of radius r with plotstyle p. \ CirclePS makes use of the Circle primitive." Combine::usage = "Combine[object, joindata] sets the value of object to the \ joining of object with joindata; however, if object has no \ value, then object is set to joindata." ComplexQ::usage = "ComplexQ[z] returns True if z is a complex number, False otherwise." ComplexTo2DCoord::usage = "ComplexTo2DCoord[x] returns the two-dimensional coordinate \ corresponding to the complex form of x. \ That is, a pair of values in the form { Re[x], Im[x] } is returned." ComplexTo2DCoordList::usage = "ComplexTo2DCoordList[zlist] returns a list of coordinates \ corresponding to the complex form of each element in zlist. \ That is, zlist is mapped through ComplexTo2DCoord." ConstantQ::usage = "ConstantQ[x] returns True if x is always constant. \ If x is an atom, then x is constant it is a number or it x has \ a Constant attribute. \ If x is a function of the form f[arg1, arg2, ...], then x is \ considered to be constant if arg1, arg2, ..., are constant." ConstantTerm::usage = "ConstantTerm[expr, x] returns the constant term of the \ expression expr." Dialogue::usage = "Dialogue is an option for all of the symbolic transforms, the \ differential/difference equations solvers, and more. \ Possible settings are False, True, or All, for no, partial, or \ full justification, respectively. \ In the case of symbolic transforms, a setting of True or All will \ cause the rule base to describe strategies being applied to compute \ the transform as well as the functions (if any) which it could not \ transform. \ If it set to All, then the rule base will also display each step \ of the transform reasoning." Element::usage = "Element[expr, n] returns the nth element of expr if n is an integer \ or list of integers. \ Element[expr, n1, n2, ..., nm] returns expr[[n1, n2,..., nm]] if \ n1, n2, ... nm are integers." EmptyQ::usage = "EmptyQ[packet] returns True the packet of data is empty." GenerateCode::usage = "GenerateCode[object] converts object to a string (if necessary) \ and then evaluates it (translates it to Mathematica code)." GeneratePattern::usage = "GeneratePattern[namestring] generates a symbol with the name \ equal to namestring followed by an underscore, which makes the \ object be a pattern which can be used for pattern matching. \ For example, GeneratePattern[\"a\"] yields the pattern (a_)." GenerateSymbol::usage = "GenerateSymbol[namestring], GenerateSymbol[namestring, trailer], \ and GenerateSymbol[namestring, trailer, header], generate a \ symbol by concatenating header, namestring, and trailer." GetAllExponents::usage = "GetAllExponents[expr, x] returns all exponents of the \ term x in the expression expr. \ GetAllExponents[z^3 + 2 z^6, z] returns {6, 3}." GetAllFactors::usage = "GetAllFactors[expr, x] returns all factors of the \ term x in the expression expr. \ GetAllFactors[z^3 + 2 z^6, z] returns {1, 2}. \ GetAllFactors[z^-3 + 2 z^-6, z] returns {1/2, 1}." GetAllShiftFactors::usage = "GetAllShiftFactors[expr, x] returns a list containing all \ shift factors in the variable x. \ The expression is traversed as is using a depth-first search. \ For example, GetAllShiftFactors[ (2 s + 2 b + c) Exp[s + b + Pi], s] \ returns { b + Pi, (2 b + c)/2 }." GetArgs::usage = "GetArgs[function] returns the argument(s) of the function. \ For example, GetArgs[ Bogus[1,2,3] ] would return 1,2,3. \ If the programmer only wishes to replace the head of a function \ with another, then use Apply instead of GetArgs. \ This function is similar to ToCollection." GetOperatorVariables::usage = "GetOperatorVariables[op] returns the variable(s) in the \ parameterized operator op. \ By default, GetOperatorVariables[ op[par1, par2, ...] ] \ returns the first parameter, par1." GetRoot::usage = "GetRoot[rule] extracts the value from an expression like \ {z -> 0.}, which is 0. in this case." GetRootList::usage = "GetRootList[p, x] returns a list of the approximate numerical roots \ of expression p, a function of x, with infinite roots removed. \ GetRootList[p, x, filter] applies filter to the list of roots \ returned by the Solve function (defaults to N). \ When GetRootList cannot find a set of roots, it will search for \ numeric roots." GetShiftFactor::usage = "GetShiftFactor[expr, x] returns a list containing the common \ shift factor in the variable x and a normalized version of expr. \ For example, GetShiftFactor[ (2 s + 2 b + c) Exp[s + b + Pi], s] \ returns {b, 2 Exp[Pi + b + s] (b + c/2 + s)}." GetStateField::usage = "GetStateField[state, field] returns the value of the slot \ field n the list state." GetVariables::usage = "GetVariables[expr] returns a list of all of the variables in \ the expression expr. \ See VariableQ for the definition of a variable." GetValue::usage = "GetValue[f[n], n, n0] finds the numeric value of f[n] at n = n0 \ and GetValue[f[n1,n2], {n1,n2}, {n01, n02}] finds the numeric \ value of f[n1,n2] at n1 = n01 and n2 = n02. \ When the first argument has the variables embedded in it, \ two arguments are sometimes enough: GetValue[ object, n0 ]. \ This is true when the object is an abstract signal." HasAttributes::usage = "HasAttributes[symbol, attribute1, attribute2, ...] returns True \ if the evaluation of symbol is another symbol and the attributes \ to be checked are a subset of the attributes of this other symbol. \ HasAttributes[Plus, {Listable, Orderless}] would return True." ImaginaryQ::usage = "ImaginaryQ[z] returns True if z is a number whose real part is zero." InRange::usage = "InRange[a, b, c, amin, cmax, leftcompare, rightcompare] returns \ True if b in between a and c. \ The inclusiveness of the interval a to c is determined by the \ arguments leftcompare and rightcompare, each of which defaults to \ LessEqual. \ So, InRange[a, b, c] returns True if a <= b <= c. \ Non-numeric values, like Infinity, can be used for amin and cmax, \ which default to -Infinity and +Infinity, respectively." InfinityQ::usage = "InfinityQ[a] will return True if a is Infinity, -Infinity, \ ComplexInfinity, DirectedInfinity[], or DirectedInfinity[r]." InformUserQ::usage = "InformUserQ[x] returns True if the options in object x contain \ Dialogue -> All or Dialogue -> True. \ It also returns True if x is All or True." ListQ::usage = "ListQ[expr] gives True if expr is a List, and False otherwise." MixedPolynomialQ::usage = "MixedPolynomialQ[p] and MixedPolynomialQ[p,x] return \ return True if p is a polynomial in negative and positive \ (mixed) powers of x. \ Note that rational numbers like 5/6 and 1 are polynomials. \ MixedPolynomialQ[x + x^-1, x] is True." MyApart::usage = "MyApart[rational_polynomial, x] decomposes the rational \ polynomial into a sum of fractions whose numerators are of \ the form (x + b)^n where b is a constant and n is an integer. \ MyApart uses GetRootList to find the roots and then calls Apart. \ MyApart[rational_polynomial, x, filter] specifies a filter \ for GetRootList: Identity for rational and N for approximate roots. \ In Mathematica 1.2, MyApart is about 25 times slower than Apart." MyCollectAll::usage = "MyCollectAll[ expression, var ] attempts to collect all \ subexpressions of expression in terms of var." MyFreeQ::usage = "MyFreeQ[expr, form], when form is not a list, yields True if no \ subexpression in expr matches form. \ If form is a list, then True is returned if expr is free of \ each element of form. \ This is similar to MyFreeQ[expr, form1, form2, ...] which expands to \ MyFreeQ[expr, form1] and MyFreeQ[expr, form2] and ...." MyMessage::usage = "MyMessage[message-label, return-value, arg1, arg2, ...] first calls \ Message[message-label, arg1, arg2, ...] and then returns return-value." NullPlot::usage = "NullPlot is a 2-d graphics object which only contains the origin." PatternQ::usage = "PatternQ[expr] returns True if the head of expr is Pattern." PointwisePlot::usage = "PointwisePlot[coordlist, text] and \ PointwisePlot[coordlist, text, multiplicitytext] \ will plot the coordinates in coordlist as text \ for 2-D and 3-D graphics. \ An optional fourth argument specifies the size of the font to use. \ For multiple occurrences of the same coordinate,\ the object multiplicitytext is displayed. \ The last two arguments are usually symbols, numbers, or \ FontForm objects." PrintIt::usage = "PrintIt[graphics, printer] will print out graphics on a printer. \ If the printer is not specified, the default printer is used." ProtectIt::usage = "ProtectIt[expr] evaluates expr. \ If it evaluates to a symbol, that symbol will be write protected. \ Rules can be written for that symbol, \ but values can no longer be assigned to it." RationalQ::usage = "RationalQ[m] returns True if m is a rational number. \ If m is an integer, then this function also return True, \ since the set of integers are a subset of rationals." RationalFunctionQ::usage = "RationalFunctionQ[f,x] returns True if expression f is of the form \ f = g(x) / h(x), where h(x) depends on x but g(x) does not have \ to depend on x. \ For example, 1 / ( x + 1 ) is a rational function \ in x but x^3 + x^2 + x / ( x + 1) is not." RationalPolynomialQ::usage = "RationalPolynomialQ[p] and RationalPolynomialQ[p,x] return \ True if p is a rational polynomial in x. \ Note that rational numbers like 5/6 and 1 are also \ rational polynomials." RealQ::usage = "RealQ[z] returns True if z is a floating-point number \ (has a head of Real), False otherwise. See RealValuedQ." RealValuedQ::usage = "RealValuedQ[z] gives True if z is a number whose imaginary \ component is 0, and gives False otherwise. See RealQ." RemoveOptions::usage = "RemoveOptions[optionlist, options] removes the options \ from optionlist." ReplaceWith::usage = "ReplaceWith[oldexpr, newexpr] is a generalized way to specify \ a substitution when the substitution may be either atomic \ and a list of substitutions." RuleAppliesQ::usage = "RuleAppliesQ[expr, rule] returns True if rule applies to expr. \ RuleAppliesQ[head[expr1, expr2, ..., exprn], rule, head] returns \ True if the rule applies to each expression expr1, expr2, ..., \ exprn." SameFormQ::usage = "SameFormQ[pattern, expr1, expr2, ...] returns True if every \ expression matches pattern via MatchQ. \ Once an expression does not match, \ this function immediately returns False." Second::usage = "Second[list] returns the second element of list." SetExclusion::usage = "SetExclusion[set1, set2, ...] returns a set equal to the union \ of the sets minus the intersection of the sets." SetStateField::usage = "SetStateField[state, field, value] will return a new state, \ which is a copy of the list state except that the value of \ the slot field will be equal to value." SPfunctions::usage = "SPfunctions maintains a current list of those new routines \ that have been loaded from the signal processing packages." SPLessGreaterRules::usage = "SPLessGreaterRules are a collection of rules for simplifying \ expressions involving inequalities." SPoperators::usage = "SPoperators maintains a current list of the new mathematical \ operators that have been loaded from the signal processing packages." SPsignals::usage = "SPsignals maintains a current list of those new signals \ (mathematical functions) that have been loaded from the \ signal processing packages." SPSimplificationRules::usage = "SPSimplificationRules are a collection of simplification rules \ that are not carried out by Simplify. \ These rules require too much overhead to encode them directly \ into Mathematica. \ See also SPSimplify." StripPackage::usage = "StripPackage[symbol] returns the symbol (as a string) after its \ context has been removed. \ To remove the package definition from every symbol in expression, \ use MapAll[StripPackaage, expression]." SubsetQ::usage = "SubsetQ[set1, set2, set3, ...] returns True if set1 is a subset \ of set2 and set2 is a subset of set3, etc." TableLookup::usage = "TableLookup[index, hlist, len, val] returns hlist[[index]] \ if index is between 1 and len, inclusive; otherwise, val is \ returned." Third::usage = "Third[list] returns the third element of list." ToCollection::usage = "ToCollection[expr] strips the head off of arg and returns \ the argument of expr as a collection. \ ToCollection returns an object that is a sequence, \ which is represented in Mathematica 1.2 as (a1, a2, ...) \ and in Mathematica 2.0 as Sequence[a1, a2, ...]. \ So, it provides a unified way of generating collections (sequences)." ToList::usage = "ToList[arg] returns arg if arg is a list. \ Otherwise, List[arg] is returned. \ ToList[arg1, arg2, ...] returns List[arg1, arg2, ...]." UnprotectIt::usage = "UnprotectIt[expr] evaluates expr. \ If it evaluates to a symbol, \ write protection will be removed for that symbol." VariableQ::usage = "VariableQ[x] returns True if x is a symbol that \ (1) does not have a numerical value associated with it and (2) does not have its Constant attribute enabled. \ Pi fails the first test, so it is not considered a variable. \ A variable can also have the form of C[n] where n is an integer \ and C is a symbol whose Constant attribute is enabled." ZeroQ::usage = "ZeroQ[x] returns True if x is 0 or 0.0" ZPolynomial::usage = "ZPolynomial[m, n] is an mth order polynomial in the discrete \ variable n defined by the product of (-n - k) for k = 0 ... m-1. \ The z-transform of the product of this polynomial and some function \ f[n] gives z^m times the mth derivative of F(z)." (* E N D U S A G E I N F O R M A T I O N *) Begin["`Private`"] (* A L T E R E X I S T I N G F U N C T I O N S *) (* And *) Unprotect[And] And/: Simplify[And[a1_, args__]] := Apply[And, Union[{a1, args}]] Protect[And] (* ClearAttributes *) Unprotect[ClearAttributes] SetAttributes[ClearAttributes, HoldFirst] Protect[ClearAttributes] (* Det *) Unprotect[Det] Det[x_?NumberQ] := x Protect[Det] (* Dot *) Unprotect[Dot] Dot[x_?NumberQ, y_?NumberQ] := x y Protect[Dot] (* Limit *) If [ TrueQ[ $VersionNumber >= 2.0 ], Unprotect[ Limit ]; Limit/: Options[Limit] := { Analytic -> True, Direction -> Automatic }; Protect[ Limit ] ] (* SetAttributes *) Unprotect[SetAttributes] SetAttributes[SetAttributes, HoldFirst] Protect[SetAttributes] (* TeXForm *) Unprotect[Re, Im] Im/: Format[ Im[x_], TeXForm ] := StringForm["\\Im{m}(``)", x] Re/: Format[ Re[x_], TeXForm ] := StringForm["\\Re{e}(``)", x] Protect[Re, Im] (* S I M P L I F I C A T I O N R U L E S *) (* PositiveOrNegative *) PositiveOrNegative[a_] := SameQ[Head[N[a]], Real] (* For minimum/maximum operations *) MinMaxRules = { Min[t1_, t2_, rest___] :> Min[t1, rest] /; N[t1 < t2], Min[t1_, t2_, rest___] :> Min[t2, rest] /; N[t1 > t2], Max[t1_, t2_, rest___] :> Max[t1, rest] /; N[t1 > t2], Max[t1_, t2_, rest___] :> Max[t2, rest] /; N[t1 < t2], Min[a_. + b_, c_. + b_, rest___] :> Min[a + b, rest] /; N[a < c], Min[a_. + b_, c_. + b_, rest___] :> Min[c + b, rest] /; N[a > c], Max[a_. + b_, c_. + b_, rest___] :> Max[c + b, rest] /; N[a < c], Max[a_. + b_, c_. + b_, rest___] :> Max[a + b, rest] /; N[a > c] } If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *) MinMaxRules = MinMaxRules ~Join~ { Min[a_, a_] :> a, Max[a_, a_] :> a } ] (* For the less than operation *) LessRules = { Less[Max[a_, b__], a_] :> Less[Max[b], a], LessEqual[Max[a_, b__], a_] :> LessEqual[Max[b], a], Less[Times[-1, b_], 0] :> Greater[b, 0], LessEqual[Times[-1, b_], 0] :> GreaterEqual[b, 0] } (* For the greater than operation *) GreaterRules = { Greater[Min[a_, b__], a_] :> Greater[Min[b], a], GreaterEqual[Min[a_, b__], a_] :> GreaterEqual[Min[b], a], Greater[Times[-1, b_], 0] :> Less[b, 0], GreaterEqual[Times[-1, b_], 0] :> LessEqual[b, 0] } (* For the absolute value operation *) AbsRules = { Abs[- a_] :> Abs[a], Abs[x_?PositiveOrNegative y_] :> Abs[x] Abs[y], Abs[x_]^n_. Abs[y_]^m_. :> 1 /; SameQ[x^n, y^(-m)] } If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *) AbsRules = AbsRules ~Join~ { Re[Abs[a_]] :> Abs[a], Im[Abs[a_]] :> 0, Abs[Abs[a_]] :> Abs[a], Abs[r_. Exp[ Complex[0, b_] a_. ] ] :> r /; PositiveOrNegative[a b r], Abs[a_] :> a /; Positive[a], Abs[a_] :> -a /; Negative[a] } ] (* For the real and imaginary operations *) ReImRules = { Re[- a_] :> - Re[a], Im[- a_] :> - Im[a], Conjugate[ Exp[ Complex[0, b_] a_. ] ] :> Exp[ Complex[0, -b] a ] /; PositiveOrNegative[a b], Conjugate[ ( a_. Conjugate[z_]^r_. + b_. )^s_. ] :> ( a z^r + b )^s /; ((r == 1) || (r == -1)) && ((s == 1) || (s == -1)) && PositiveOrNegative[a] && PositiveOrNegative[b], Conjugate[a_ b_] :> Conjugate[a] Conjugate[b] } If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *) ReImRules = ReImRules ~Join~ { Re[a_] :> a /; PositiveOrNegative[a], Im[a_] :> 0 /; PositiveOrNegative[a], Re[r_. Exp[ Complex[0, b_] a_. ] ] :> r Cos[b a] /; PositiveOrNegative[a b r], Im[r_. Exp[ Complex[0, b_] a_. ] ] :> r Sin[b a] /; PositiveOrNegative[a b r], Re[Im[a_]] :> Im[a], Im[Re[a_]] :> 0, Re[Re[a_]] :> Re[a], Im[Im[a_]] :> 0, Conjugate[Conjugate[x_]] :> x, Conjugate[Re[x]] :> Re[x], Conjugate[Im[x]] :> Im[x], Conjugate[x_] :> x /; PositiveOrNegative[x] } ] (* For products of exponentials *) TimesRules = { a_^k_ b_^k_ :> 1 /; ( a == 1/b ) && PositiveOrNegative[k] } (* For exponential and logarithmic functions *) ExpLogRules = { base_^(c_. Log[base_, b_]) :> b^c, Log[c_. Exp[b_]] :> Log[c] + b, Log[base_, c_. base_^b_] :> Log[base, c] + b } If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *) ExpLogRules = ExpLogRules ~Join~ { Exp[c_. Log[b_]] :> b^c, Erf[-a_] :> -Erf[a], Exp[ a_. Complex[0, b_] Pi ] :> Exp[ Mod[a b, 2] I Pi ] /; RationalQ[a b] && ( (a b < 0) || (a b >= 2) ) } ] (* Evenness and oddness of functions *) EvenOddRules = { Sign[-x_] :> -Sign[x], BesselI[n_Integer, -x_] :> (-1)^n BesselI[n, x], BesselJ[n_Integer, -x_] :> (-1)^n BesselJ[n, x] } If [ ! TrueQ[ $VersionNumber >= 2.0 ], EvenOddRules = EvenOddRules ~Join~ { Sin[-x_] :> -Sin[x], Cos[-x_] :> Cos[x], Tan[-x_] :> -Tan[x] } ] (* For other simplifications *) If [ TrueQ[ $VersionNumber >= 2.0 ], OtherRules = { ( ((x_^l_.) t_)^k_ :> x^(l k) t^k /; PositiveOrNegative[x] && PositiveOrNegative[l] && PositiveOrNegative[k] ) }, OtherRules = { Sqrt[x_] :> I Sqrt[-x] /; x < 0, Tan[Complex[0, b_] w_.] :> I Tanh[b w], Sin[Complex[0, b_] w_.] :> I Sinh[b w], Cos[Complex[0, b_] w_.] :> Cosh[b w] } ] SPSimplificationRules = Join[MinMaxRules, AbsRules, TimesRules, ReImRules, ExpLogRules, OtherRules, EvenOddRules] SPLessGreaterRules = Join[LessRules, GreaterRules] (* M E S S A G E S *) PointwisePlot::invalid = "Null coordinate list passed." Dialogue::notvalid = "The Dialogue option must be True, False, or All: `` is not valid." (* G L O B A L S *) NullPlot := Graphics [ PointSize[0.007] ] (* NullPlot := Graphics [ Point[{0, 0}], DisplayFunction -> Identity ] *) (* F U N C T I O N S *) (* AllSubsets *) AllSubsets[x_List] := Sort[ Map[Flatten, Distribute[Map[{{},{#1}}&, x], List]] ] (* Arrow2D *) Arrow2D[tail_, plotwidth_, plotheight_:1] := Arrow2D[tail, plotwidth, plotheight, plotheight] Arrow2D[tail_, plotwidth_, plotheight_, length_?ImaginaryQ] := Arrow2D[tail, plotwidth, plotheight, Im[length], Dashing[{0.02,0.02}]] Arrow2D[tail_, plotwidth_, plotheight_, length_, style___] := Block [ {arrowhead, arrowleft, arrowright, head, xoffset, yoffset}, xoffset = 0.02 plotwidth; yoffset = 0.1 (Re[plotheight] + Abs[length]) Sign[length]; head = tail + { 0, length }; arrowleft = head + { - xoffset, - yoffset }; arrowright = head + { xoffset, - yoffset }; arrowhead = head + { 0, - yoffset }; Graphics[ { Thickness[0.006], Line[{head, arrowleft, arrowright, head}], style, Line[{tail, arrowhead}] } ] ] (* AssociateItem *) AssociateItem[item_, lookuptable_, assoctable_] := Map[Function[var, AssociateItem[var, lookuptable, assoctable]], item] /; ListQ[item] AssociateItem[item_, lookuptable_, assoctable_] := If [ MemberQ[lookuptable, item], assoctable [[ ToCollection[ToCollection[Position[lookuptable, item] ]] ]] ] /; ! ListQ[item] (* Assuming *) AssumingList = {} Assuming[] := AssumingList = {} Assuming[All] := Apply[And, AssumingList] Assuming[True] := Null Assuming[True, x_] := Null Assuming[cond_] := AppendTo[AssumingList, cond] Assuming[cond_, op_List] := Assuming[cond, SameQ[Replace[Dialogue, op], All]] Assuming[cond_, True] := Block [ {}, Print[ "assuming ", cond ]; Assuming[cond] ] Assuming[cond_, x_] := Assuming[cond] (* CirclePS *) CirclePS[r_] := Graphics[ Circle[{0, 0}, r] ] CirclePS[r_, p_] := Graphics[ { p, Circle[{0, 0}, r] } ] (* Combine *) SetAttributes[Combine, {HoldFirst}] Combine[object_, joindata_] := If [ ValueQ[object], object = Sort[object ~Join~ joindata], object = joindata ] (* ComplexQ *) ComplexQ[z_] := NumberQ[z] && SameQ[Head[z], Complex] (* ComplexTo2DCoord and ComplexTo2DCoordList *) ComplexTo2DCoord[z_] := { Re[z], Im[z] } ComplexTo2DCoordList[zlist_] := Map[ ComplexTo2DCoord, zlist ] (* ConstantQ *) ConstantQ[x_?AtomQ] := NumberQ[x] || HasAttributes[x, Constant] ConstantQ[f_[x__]] := Apply[And, Map[ConstantQ, List[x]]] (* ConstantTerm *) ConstantTerm[expr_, z_:Global`x] := Block [ {nonpropterms}, keepconstants[e_] := If [ MyFreeQ[e,z], e, 0 ]; nonpropterms = Coefficient[expr, z, 0]; If [ MyFreeQ[nonpropterms, z], nonpropterms, Map[keepconstants, nonpropterms] ] ] (* Element *) properIndex[i_Integer] := True properIndex[i_List] := Apply[And, Map[IntegerQ, Flatten[i]]] properIndex[i___] := properIndex[ {i} ] Element[h_[args__], i___] := h[args] [[i]] /; properIndex[i] (* EmptyQ *) EmptyQ[x_?AtomQ] := False EmptyQ[h_[]] := True EmptyQ[h_[values__]] := False (* GenerateCode *) GenerateCode[code_] := ToExpression[ToString[code]] (* GeneratePattern *) GeneratePattern[name_] := GenerateSymbol[name, "_"] (* GenerateSymbol *) GenerateSymbol[name_] := GenerateCode[name] GenerateSymbol[name_, trailer_] := GenerateCode[StringForm["````", name, trailer]] GenerateSymbol[name_, trailer_, header_] := GenerateCode[StringForm["``````", header, name, trailer]] (* GetAllShiftFactors *) shiftFactorList = {} addFactor[f_] := Block [ {}, AppendTo[shiftFactorList, f]; f ] GetAllShiftFactors[expr_, s_] := Block [ {normexpr, rules}, shiftFactorList = {}; rules = (a_. s + b_. :> addFactor[b/a] /; FreeQ[b, s]); If [ ! TrueQ[ $VersionNumber >= 2.0 ], rules = { (a_. s + b__) :> addFactor[Plus[b]/a] /; FreeQ[ Plus[b], s ], rules, s :> addFactor[0] } ]; normexpr = expr /. rules; shiftFactorList ] (* GetArgs *) GetArgs[h_[]] := Null GetArgs[h_[x__][d__]] := d GetArgs[h_[x__]] := x GetArgs[e1_, e__] := ToCollection[ GetArgs[e1], GetArgs[e] ] (* GetAllExponents and GetAllFactors *) depthfirstsearch[expr_, lhs_, rule_] := Block [ {cur, i, len, newexpr}, If [ ! AtomQ[expr], len = Length[expr]; For [ i = 1, i <= len, i++, cur = expr[[i]]; If [ MatchQ[cur, lhs], newexpr = Replace[cur, rule]; If [ SameQ[cur, newexpr], depthfirstsearch[cur, lhs, rule], PrependTo[list, newexpr] ], depthfirstsearch[cur, lhs, rule] ] ] ]; Null ] depthdriver[expr_, lhs_, rule_] := Block [ {depthflag = True}, list = {}; If [ MatchQ[expr, lhs], (* check top level first *) newexpr = Replace[expr, rule]; If [ ! SameQ[expr, newexpr], PrependTo[list, newexpr]; depthflag = False ] ]; If [ depthflag, depthfirstsearch[expr, lhs, rule] ]; list ] GetAllExponents[ expr_, z_ ] := depthdriver[ expr, c_. z^n_., c_. z^n_. :> If [ FreeQ[c, z], n, c z^n ] ] GetAllFactors[ expr_, z_ ] := depthdriver[ expr, c_. z^n_., c_. z^n_. :> If [ FreeQ[c, z], c^Sign[n], c z^n ] ] /. ( Sign[x_] :> 1 ) (* GetOperatorVariables *) GetOperatorVariables[ h_[var_, rest___] ] := var (* GetRoot *) GetRoot[{}] := {} (* no roots *) GetRoot[rule_] := Second[First[rule]] (* GetRootList *) extractRoot[ ToRules[x_] ] := N [ ToRules[x] ] (* ToRules returns collection *) extractRoot[ y_ ] := y goodroot[r_] := ! MatchQ[r, DirectedInfinity[___]] GetRootList[p_, x_, filter_:N] := Select[ Map[ GetRoot, Map[extractRoot, filter[Solve[p == 0, x]]] ], goodroot ] (* GetShiftFactor *) commonFactor = 0 myMin[ x1_?RealValuedQ, x2_?RealValuedQ ] := Min[x1, x2] myMin[ x1_?RealValuedQ, Complex[re2_,im2_] ] := Complex[myMin[x1, re2], im2] myMin[ Complex[re1_,im1_], Complex[re2_,im2_] ] := Complex[myMin[re1,re2], myMin[im1,im2] ] reduce[ 0, x_, term_ ] := term (* stopping conditions *) reduce[ x_, 0, term_ ] := term reduce[ x1_?NumberQ + rest1_., x2_?NumberQ + rest2_., term_ ] := reduce[ rest1, rest2, term + myMin[x1,x2] ] reduce[ x1_. y_ + rest1_., x2_. y_ + rest2_., term_ ] := reduce[ rest1, rest2, term + myMin[x1,x2] y ] /; NumberQ[x1] && NumberQ[x2] && ! NumberQ[y] reduce[ a_, b_, term_ ] := term (* incomplete reduction *) extractShift[ a_, b_, s_ ] := Block [ {shift}, shift = Expand[b/a]; If [ ValueQ[commonFactor], commonFactor = reduce[shift, commonFactor, 0], commonFactor = shift ]; a ( s + shift ) ] GetShiftFactor[expr_, s_] := Block [ {normexpr, rules}, Clear[commonFactor]; rules = (a_. s + b_. :> extractShift[a, b, s]); If [ ! TrueQ[ $VersionNumber >= 2.0 ], rules = { (a_. s + b__) :> extractShift[a, Plus[b], s], rules, s :> extractShift[1, 0, s] } ]; normexpr = expr /. rules; If [ ! ValueQ[commonFactor], commonFactor = 0 ]; { commonFactor, normexpr } ] (* GetStateField *) GetStateField[state_List, field_] := state[[field]] (* GetVariables *) extractrules = { f_[x__][y__][z__] :> bogus[x, y, z], f_[x__][y__] :> bogus[x, y], (x_ -> y_) :> {}, (x_ :> y_) :> {} } GetVariables[x_] := Union[ Select[ Level[x /. extractrules, Infinity], VariableQ ] ] (* GetValue *) GetValue[f_, n_Symbol, n0_] := Block [ {value}, value = N [ f /. n -> n0 ]; If [ NumberQ[value], value, N [ Limit[f, n -> n0] ] ] ] GetValue[f_, {n1_Symbol, n2_Symbol}, {n01_, n02_}] := Block [ {value}, value = N [ f /. { n1 -> n01, n2 -> n02 } ]; If [ NumberQ[value], value, N[ Limit[ Limit[f, n1 -> n01], n2 -> n02] ] ] ] (* HasAttributes *) HasAttributes[symbol_, attrib1_, attribs__] := HasAttributes[symbol, {attrib1, attribs}] HasAttributes[symbol_Symbol, attrib_] := Block [ {attributes, protected}, attributes = Attributes[Attributes]; Unprotect[Attributes]; ClearAttributes[Attributes, {HoldFirst, HoldAll, HoldRest}]; protected = If [ AtomQ[attrib], MemberQ[Attributes[symbol], attrib], SubsetQ[attrib, Attributes[symbol]] ]; SetAttributes[Attributes, attributes]; protected ] (* ImaginaryQ *) ImaginaryQ[z_] := NumberQ[z] && ZeroQ[Re[z]] (* InRange, function will be automatically threaded if a,b,c are not atoms *) SetAttributes[MyInRange, Listable] InRange[a_, b_, c_, amin_:-Infinity, cmax_:Infinity, leftcompare_:LessEqual, rightcompare_:LessEqual ] := Apply[And, ToList[MyInRange[a, b, c, amin, cmax, leftcompare, rightcompare]]] MyInRange[a_, b_, c_, amin_, cmax_, leftcompare_, rightcompare_] := Which [ SameQ[a, amin] && SameQ[c, cmax], True, SameQ[a, amin], SameQ[b, amin] || rightcompare[b, c], SameQ[c, cmax], SameQ[b, cmax] || leftcompare[a, b], True, leftcompare[a, b] && rightcompare[b, c] ] (* InfinityQ *) InfinityQ[e_List] := Apply[And, Map[InfinityQ, e]] InfinityQ[DirectedInfinity[]] := True InfinityQ[DirectedInfinity[r_]] := True InfinityQ[a_] := False (* InformUserQ *) informuser[All] := True informuser[True] := True informuser[False] := False informuser[x_] := False InformUserQ[x_List] := informuser[Replace[Dialogue, x]] InformUserQ[x_] := informuser[x] (* ListQ-- it is an undocumented primitive in Mma 2.0+ *) (* in 2.0, it does not always return True or False *) ListQ[object_] := SameQ[Head[object], List] (* MixedPolynomialQ *) twosided[ c_. z_^r_., z_ ] := FreeQ[c, z] && IntegerQ[r] twosided[ c_, z_ ] := FreeQ[c, z] MixedPolynomialQ[c_] := MixedPolynomialQ[c, Global`x] MixedPolynomialQ[x_?AtomQ, z_] := True MixedPolynomialQ[Plus[a_, b__], z_] := Apply[And, Map[twosided[#1, z]&, {a, b}]] MixedPolynomialQ[x_, z_] := twosided[x, z] (* MyApart -- kludge around the way Apart does partial fractions *) (* Root denominator and replace roots with symbols *) MyApart[ratpoly_, x_, filter_:Identity] := Block [ {apart, denom, denomfactored, normfact, numer, partfrac, rootlist, rootmult, rules}, numer = Numerator[ratpoly]; denom = Denominator[ratpoly]; normfact = Last[ CoefficientList[denom, x] ]; numer /= normfact; denom /= normfact; rootlist = Sort[ GetRootList[denom, x, filter] ]; { denomfactored, rules } = multiplicityform[rootlist, x]; apart = Apart[numer / denomfactored, x]; partfrac = apart /. rules; partfrac /. ( a_. / (b_ c_) :> a / ( Together[b] c ) /; FreeQ[b, x] && ! FreeQ[c, x] ) ] multiplicityform[ roots_, x_ ] := Block [ {count = 1, cur, denom = 1, i, last, length, sublist = {}, sym = 1}, Clear[localvar]; (* localvar is global to package *) length = Length[roots]; last = First[roots]; For [ i = 2, i <= length, i++, cur = roots[[i]]; If [ SameQ[ cur, last ], count++, denom *= (x + localvar[sym])^count; PrependTo[ sublist, localvar[sym] -> -last ]; sym++; count = 1 ]; last = cur ]; denom *= (x + localvar[sym])^count; PrependTo[ sublist, localvar[sym] -> -last ]; { denom, sublist } ] (* MyCollectAll *) MyCollectAll[ a_, x_ ] := a /. ( h_ :> Collect[h, x] /; PolynomialQ[h,x] || MixedPolynomial[h,x] ) (* MyFreeQ *) MyFreeQ[expr_, {form_}] := FreeQ[expr, form] MyFreeQ[expr_, {form1_, forms__}] := FreeQ[expr, form1] && MyFreeQ[expr, forms] MyFreeQ[expr_, form_] := FreeQ[expr, form] MyFreeQ[expr_, form1_, forms__] := FreeQ[expr, form1] && MyFreeQ[expr, forms] (* MyMessage *) SetAttributes[MyMessage, HoldFirst] MyMessage[message_, return_] := Block [ {}, Message[message]; return ] MyMessage[message_, return_, args__] := Block [ {}, Message[message, args]; return ] (* PatternQ *) PatternQ[expr_] := SameQ[Head[expr], Pattern] (* PointwisePlot *) PointwisePlot[coordlist_, singtext_] := PointwisePlot[coordlist, singtext, singtext] (* plots each unique set of coordinates. multiple occurrences of the *) (* same coordinate are plotted as <text>(n), where n is the number of *) (* occurrences. First, the coordinate list is sorted. A Null is *) (* appended because the scanning function compares the current *) (* coordinate with the last, so that Null forces the last coordinate *) (* to be processed. After the pointwiseplot graphics commands are *) (* built up, the resulting plot is returned as a graphics object. *) (* The point size of the text defaults to 18. Supported font sizes *) (* are 10, 12, 14, 16, 18, 20, 24, ... *) PointwisePlot[coordlist_, singtext_, multtext_, fontsize_:18] := Block [ {counter = 1, text, lastcoord = Null, pointwiseplot = {}, ptsize, str}, ptsize = Round[fontsize]; Scan [ Function[ coord, Which [ SameQ[lastcoord, Null], (* initial cond. *) counter = 1; lastcoord = coord, SameQ[coord, lastcoord], (* multiple occur. *) ++counter, True, (* plot it *) str = If [ SameQ[counter, 1], singtext, multtext ]; text = If [ TrueQ[$VersionNumber >= 2.0], FontForm[str, {"Bold", ptsize}], FontForm[str, "Bold", ptsize] ]; AppendTo[ pointwiseplot, Text[text, lastcoord] ]; counter = 1; lastcoord = coord ] ], Append[Sort[coordlist], Null] ]; Graphics[pointwiseplot] ] /; ! EmptyQ[coordlist] PointwisePlot[coordlist_, singtext_, multtext_] := MyMessage[PointwisePlot::invalid, NullPlot] /; EmptyQ[coordlist] (* PrintIt *) PrintIt[graphics_] := Display["!psfix | lpr", graphics] PrintIt[graphics_, printer_] := Display[ToString[StringForm["!psfix | lpr -P``", printer]], graphics] (* ProtectIt *) ProtectIt[symbol_Symbol] := Apply[Protect, {symbol}] (* RationalQ *) RationalQ[z_Integer] := True RationalQ[z_Rational] := True RationalQ[z_] := False (* RationalFunctionQ *) RationalFunctionQ[f_, x_:Global`x] := ( ! SameQ[Head[f], Plus] ) && ( ! MyFreeQ[Denominator[f], x] ) (* RationalPolynomialQ *) RationalPolynomialQ[p_] := PolynomialQ[Numerator[p]] && PolynomialQ[Denominator[p]] RationalPolynomialQ[p_, x_] := PolynomialQ[Numerator[p], x] && PolynomialQ[Denominator[p], x] (* RealQ *) RealQ[z_] := SameQ[Head[z], Real] (* RealValuedQ *) RealValuedQ[z_] := NumberQ[z] && ZeroQ[Im[z]] (* RemoveOptions *) badOptionList = {} goodOptionQ[ a_ -> b_ ] := ! MemberQ[badOptionList, a] goodOptionQ[ a_ :> b_ ] := ! MemberQ[badOptionList, a] goodOptionQ[ x_ ] := False RemoveOptions[ oplist_List, badoplist_List ] := Block [ {}, badOptionList = badoplist; Select[ oplist, goodOptionQ ] ] (* ReplaceWith *) SetAttributes[ReplaceWith, {Listable}] ReplaceWith[org_, val_] := org -> val (* RuleAppliesQ *) (* Yes, I tried the "efficient" way of separating the lhs *) (* and rhs to see if the lhs applies to an expression; *) (* The would avoid the evaluation of the right-hand side. *) (* The main problem is that we are not guaranteed to run *) (* through all possible pattern matches since this separation *) (* only considers one pattern match. Therefore, I had to *) (* encode this by evaluating the rule using Replace. *) RuleAppliesQ[expr_, rule_] := ! SameQ[expr, Replace[expr, rule]] RuleAppliesQ[expr_, rule_, True] := Apply[ And, Map[ RuleAppliesQ[#, rule]&, Apply[List, expr] ] ] (* SameFormQ *) SameFormQ[form_, expr_] := MatchQ[expr, form] SameFormQ[form_, expr1_, expr__] := SameFormQ[form, expr1] && SameFormQ[form, expr] (* Second *) Unprotect[Second] Second[x_] := x[[2]] Protect[Second] (* SetExclusion *) SetExclusion[sets__] := Complement[Union[sets], Intersection[sets]] (* SetStateField *) SetStateField[state_List, field_, value_] := Block [ {newstate}, newstate = state; newstate[[field]] = value; newstate ] (* StripPackage *) StripPackage[symbol_Symbol] := StripPackage[ ToString[symbol] ] StripPackage[symbol_String] := Block [ {expandedstring, pos}, expandedstring = Characters[symbol]; pos = Position[expandedstring, "`"]; If [ SameQ[pos, {}], symbol, Apply[ StringJoin, Drop[expandedstring, Last[Last[pos]]] ] ] ] StripPackage[x_] := x (* SubsetQ *) SubsetQ[x1_] := True SubsetQ[x1_, x2_] := Block [ {x1sorted}, x1sorted = Sort[x1]; SameQ[x1sorted, Intersection[x1sorted, x2]] ] SubsetQ[x1_, x2_, x__] := SubsetQ[x1, x2] && SubsetQ[x2, x] (* TableLookup *) TableLookup[index_, table_, len_, val_] := (* multidimensional *) Which [ TrueQ[ Apply[Or, Map[InfinityQ, index]] ], val, TrueQ[ InRange[1, index, len] ], Apply[Part, {table} ~Join~ index], True, val ] /; ListQ[index] TableLookup[index_, table_, len_, val_] := (* one-dimensional *) Which [ InfinityQ[index], val, TrueQ[ 1 <= index <= len ], table[[index]], True, val ] /; ( InfinityQ[index] || IntegerQ[index] ) && IntegerQ[len] (* Third *) Third[x_] := x[[3]] (* ToCollection *) ToCollection[x_?AtomQ] := x ToCollection[h_[args___]] := args ToCollection[a__] := a (* ToList *) ToList[] := {} ToList[arg_List] := arg ToList[arg_] := List[arg] /; ! SameQ[Head[arg], List] ToList[arg1_, args__] := List[arg1, args] (* UnprotectIt *) UnprotectIt[symbol_Symbol] := Block [ {attributes}, attributes = Attributes[Unprotect]; Unprotect[Unprotect]; ClearAttributes[Unprotect, {HoldFirst, HoldAll, HoldRest}]; Unprotect[symbol]; SetAttributes[Unprotect, attributes] ] (* VariableQ *) VariableQ[x_Symbol] := ! ConstantQ[x] VariableQ[x_[n_Integer]] := HasAttributes[x, Constant] VariableQ[x_] := False (* ZeroQ *) ZeroQ[x_] := SameQ[x, 0] || SameQ[x, 0.0] (* ZPolynomial *) ZPolynomial[m_Integer, n_] := (-1)^m Expand[ Product[n + k, {k, 0, m-1}] ] /; ( m > 0 ) (* E N D P A C K A G E *) End[] EndPackage[] If [ TrueQ[ $VersionNumber >= 2.0 ], On[ Set::wrsym ]; On[ SetDelayed::write ]; On[ General::spell ]; On[ General::spell1 ] ] (* H E L P I N F O R M A T I O N *) Block [ {newfuns}, newfuns = { AllSubsets, Assuming, CirclePS, Combine, ComplexQ, ComplexTo2DCoord, ComplexTo2DCoordList, ConstantQ, ConstantTerm, Element, GenerateCode, GeneratePattern, GenerateSymbol, GetAllExponents, GetAllFactors, GetAllShiftFactors, GetArgs, GetRoot, GetRootList, GetShiftFactor, GetStateField, GetValue, GetVariables, ImaginaryQ, InRange, InfinityQ, InformUserQ, ListQ, MixedPolynomialQ, MyApart, MyCollectAll, MyFreeQ, MyMessage, PointwisePlot, PrintIt, RationalFunctionQ, RationalPolynomialQ, RationalQ, RealQ, RealValuedQ, RemoveOptions, ReplaceWith, RuleAppliesQ, SameFormQ, Second, SetExclusion, SetStateField, StripPackage, SubsetQ, TableLookup, Third, ToCollection, ToList, VariableQ, ZeroQ, ZPolynomial }; SPfunctions = Combine[SPfunctions, newfuns]; Apply[Protect, newfuns]; Protect[Dialogue] ] Protect[ SPSimplificationRules ] (* E N D I N G M E S S A G E *) If [ ! $loaded, Print["Support module has been loaded."] ] Remove[ $loaded ]